home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / MCL Utilities / xcmd-access.lisp < prev   
Encoding:
Text File  |  1990-08-31  |  28.0 KB  |  669 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;; Copyright 1990 by Adam Chipkin for Apple Computer, Inc.
  3. ;;; Ruben Kleiman provided consultation and resource handling code.
  4. ;;;
  5.  
  6. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  7. ;;;                                                                                         ;;;
  8. ;;;                           Extension to Allegro Common Lisp                              ;;;
  9. ;;;                     to support calls to HyperTalk XMCDs and XFCNs                       ;;;
  10. ;;;                                                                                         ;;;                                                                                         ;;;
  11. ;;;  Created: July 3, 1990                                                                  ;;;
  12. ;;; Last Mod: August 15, 1990                                                               ;;;
  13. ;;;                                                                                         ;;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ;;;
  17. ;;;   -------------------------
  18. ;;;    I N S T R U C T I O N S
  19. ;;;   -------------------------
  20. ;;;
  21. ;;;    (1)  A.  Copy the 'XCMD-Access' folder into the folder your 'Macintosh Allegro Lisp'
  22. ;;;             application is in, then add its pathname to Allegro's '*module-search-path*'
  23. ;;;             global variable:
  24. ;;;
  25. ;;;                  (pushnew (pathname "ccl;XCMD-Access:") *module-search-path*)
  26. ;;;
  27. ;;;             Now Allegro will recognize 'xcmd-access.fasl' as a module and you can simply
  28. ;;;             'require' the module:
  29. ;;;
  30. ;;;                  (require 'xcmd-access)
  31. ;;;
  32. ;;;         --OR--
  33. ;;;
  34. ;;;         B.  Just 'eval' this buffer.
  35. ;;;
  36. ;;;
  37. ;;;    (2)  Now the the two entry functions 'get-xcmd-handle' and 'do-xcmd' are interned.
  38. ;;;         NOTE:  You don't have to use 'get-xcmd-handle'; it just allows you to enhance
  39. ;;;         the performance of 'do-xcmd'.  When you give 'do-xcmd' the string name of the
  40. ;;;         XCMD or XFCN resource, it calls 'get-xcmd-handle' for you.  So if you plan to
  41. ;;;         call a certain XCMD or XFCN repeatedly, you can avoid redundant calls to
  42. ;;;         'get-xcmd-handle' by getting and remembering the handle yourself once at the
  43. ;;;         start, and then giving 'do-xcmd' the handle instead of the name each time you
  44. ;;;         call it.
  45. ;;;
  46. ;;;         Using 'do-xcmd' is straightforward: the first argument is the name of the XCMD
  47. ;;;         or XFCN (or the handle to its resource) and all subsequent arguments are string
  48. ;;;         parameters that are passed to the XCMD or XFCN.  'do-xmcd' returns the string
  49. ;;;         returned by the XCMD or XFCN.  See end of this file for examples...
  50. ;;;
  51. ;;;
  52. ;;;
  53. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. ;;;                                                                                         ;;;
  56. ;;;                            D  E  F  I  N  I  T  I  O  N  S                              ;;;
  57. ;;;                                                                                         ;;;
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60. ;;; Make sure traps are available:
  61. (require :traps)
  62.  
  63. ;;; Establish pathname:
  64. (def-logical-pathname "xcmd" "ccl;XCMD-Access:")
  65.  
  66. (eval-when (eval compile load)
  67.   ;;; Define the XcmdBlock record type for communication to and from XCMDs:
  68.   (defrecord (XCmdBlock :pointer)
  69.     (paramCount  integer)
  70.     (param1      handle)
  71.     (param2      handle)
  72.     (param3      handle)
  73.     (param4      handle)
  74.     (param5      handle)
  75.     (param6      handle)
  76.     (param7      handle)
  77.     (param8      handle)
  78.     (param9      handle)
  79.     (param10     handle)
  80.     (param11     handle)
  81.     (param12     handle)
  82.     (param13     handle)
  83.     (param14     handle)
  84.     (param15     handle)
  85.     (param16     handle)
  86.     (returnValue handle)
  87.     (passFlag    boolean)
  88.     (entryPoint  pointer)
  89.     (request     integer)
  90.     (result      integer)
  91.     (inarg1      pointer) ;; These were 'longint's, but they are sometimes used as pointers;
  92.     (inarg2      pointer) ;; making the field-types 'pointer' stops Allegro from fiddling with
  93.     (inarg3      pointer) ;; the high bits.
  94.     (inarg4      pointer)
  95.     (inarg5      pointer)
  96.     (inarg6      pointer)
  97.     (inarg7      pointer)
  98.     (inarg8      pointer)
  99.     (outarg1     pointer)
  100.     (outarg2     pointer)
  101.     (outarg3     pointer)
  102.     (outarg4     pointer)))
  103.  
  104. (eval-when (eval compile)
  105.   ;; Define the callback request constants:
  106.   (defconstant $xreqSendCardMessage 1)
  107.   (defconstant $xreqEvalExpr        2)
  108.   (defconstant $xreqStringLength    3)
  109.   (defconstant $xreqStringMatch     4)
  110.   (defconstant $xreqSendHCMessage   5)
  111.   (defconstant $xreqZeroBytes       6)
  112.   (defconstant $xreqPasToZero       7)
  113.   (defconstant $xreqZeroToPas       8)
  114.   (defconstant $xreqStrToLong       9)
  115.   (defconstant $xreqStrToNum       10)
  116.   (defconstant $xreqStrToBool      11)
  117.   (defconstant $xreqStrToExt       12)
  118.   (defconstant $xreqLongToStr      13)
  119.   (defconstant $xreqNumToStr       14)
  120.   (defconstant $xreqNumToHex       15)
  121.   (defconstant $xreqBoolToStr      16)
  122.   (defconstant $xreqExtToStr       17)
  123.   (defconstant $xreqGetGlobal      18)
  124.   (defconstant $xreqSetGlobal      19)
  125.   (defconstant $xreqGetFieldByName 20)
  126.   (defconstant $xreqGetFieldByNum  21)
  127.   (defconstant $xreqGetFieldByID   22)
  128.   (defconstant $xreqSetFieldByName 23)
  129.   (defconstant $xreqSetFieldByNum  24)
  130.   (defconstant $xreqSetFieldByID   25)
  131.   (defconstant $xreqStringEqual    26)
  132.   (defconstant $xreqReturnToPas    27)
  133.   (defconstant $xreqScanToReturn   28)
  134.   (defconstant $xreqScanToZero     39)
  135.   (defconstant $xreqSendHCEvent    41)
  136.   
  137.   ;; Define the callback result constants:
  138.   (defconstant $xresSucc            0)
  139.   (defconstant $xresFail            1)
  140.   (defconstant $xresNotImp          2)
  141.   
  142.   ;; Define the operating-system error constant 'noErr':
  143.   (defconstant $noErr               0))
  144.  
  145. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  146. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  147. ;;;                                                                                         ;;;
  148. ;;;                                  G  L  O  B  A  L  S                                    ;;;
  149. ;;;                                                                                         ;;;
  150. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  151. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  152. (defvar *params*)
  153. (if (not (boundp '*params*))
  154.   (setq *params* (make-record :XCmdBlock)))      ; The XCmdBlock must be global to
  155.                                                  ; this code since the callback
  156.                                                  ; routine is not given its pointer
  157.  
  158. (defvar *handles* nil)         ; Handles needing eventual disposal (specifically,
  159.                                ; those created by the 'PasToZero' callback)
  160.  
  161. (defvar *logstream* nil)       ; A log of XCMD calls and callback activity is written
  162.                                ; to this stream
  163.  
  164. (defvar *requests*             ; Records the symbols of the existing callback requests
  165.   (vector nil                  ; in a vector (index = requestNumber) for fast lookup
  166.           'x-SendCardMessage   ; by the 'CALLBACK-HANDLER' function
  167.           'x-EvalExpr
  168.           'x-StringLength
  169.           'x-StringMatch
  170.           'x-SendHCMessage
  171.           'x-ZeroBytes
  172.           'x-PasToZero
  173.           'x-ZeroToPas
  174.           'x-StrToLong
  175.           'x-StrToNum
  176.           'x-StrToBool
  177.           'x-StrToExt
  178.           'x-LongToStr
  179.           'x-NumToStr
  180.           'x-NumToHex
  181.           'x-BoolToStr
  182.           'x-ExtToStr
  183.           'x-GetGlobal
  184.           'x-SetGlobal
  185.           'x-GetFieldByName
  186.           'x-GetFieldByNum
  187.           'x-GetFieldByID
  188.           'x-SetFieldByName
  189.           'x-SetFieldByNum
  190.           'x-SetFieldByID
  191.           'x-StringEqual
  192.           'x-ReturnToPas
  193.           'x-ScanToReturn
  194.           nil
  195.           nil
  196.           nil
  197.           nil
  198.           nil
  199.           nil
  200.           nil
  201.           nil
  202.           nil
  203.           nil
  204.           'x-ScanToZero
  205.           nil
  206.           'x-SendHCEvent))
  207.  
  208.  
  209. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  210. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  211. ;;;                                                                                         ;;;
  212. ;;;                    S  U  P  P  O  R  T      F  U  N  C  T  I  O  N  S                   ;;;
  213. ;;;                                                                                         ;;;
  214. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  215. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  216. ;;;
  217. ;;; XCMD callback handler:
  218. ;;;
  219. ;;; The address of this function is passed, via the XcmdBlock, to the XCMD or XFCN to allow
  220. ;;; it to invoke our callback routines.  The routine indicated by the 'request' field of the
  221. ;;; XcmdBlock is invoked if it's implemented; if it's not implemented, the function indicates
  222. ;;; that in the 'result' field of the XcmdBlock. 
  223. ;;;
  224. ;;; IMPORTANT NOTE: HyperCard makes available to XCMDs all of the callback routines listed
  225. ;;; in above (in the definition of the '*REQUESTS*' variable).  In this code, however, the
  226. ;;; majority are NOT implemented -- the callback handler simply ignores requests for
  227. ;;; unimplemented routines.  I've provided the log feature so that you can see exactly
  228. ;;; which routines a given XCMD expects and only implement them as needed.  The callbacks
  229. ;;; below should serve as models for any you'll need to write yourself.  Note that all
  230. ;;; callback functions must be defined in the same package 'CALLBACK-HANDLER' is in.
  231. ;;; 
  232. ;;; For reasonably thorough descriptions of the semantics of each callback routine, see
  233. ;;; pages 69-121 of Gary Bond's book 'XCMDs FOR HYPERCARD', MIS: Press, Portland, OR, 1988.
  234. ;;;
  235. (defpascal callback-handler ()
  236.   (without-interrupts
  237.    (let ((callback-fcn (aref *requests* (rref *params* :XCmdBlock.request)))
  238.          callback-result)
  239.  
  240.      (if *logstream*
  241.        (format *logstream* "  [callback]: ~A (request code ~D)"
  242.                (subseq (string callback-fcn) 2)
  243.                (rref *params* :XCmdBlock.request)))
  244.  
  245.      (setq callback-fcn (fboundp callback-fcn))
  246.      (setq callback-result
  247.            (if callback-fcn
  248.              (funcall callback-fcn) ;; If the function's here, call it and return its result.
  249.              $xresNotImp))          ;; Else tell the XCMD that the callback is not implemented.
  250.  
  251.      (if *logstream*
  252.        (format *logstream* "~%")))))
  253.  
  254.  
  255. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  256. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  257. ;;;
  258. ;;; Used for logging.
  259. ;;;
  260. ;;; Writes the given character string to the given stream; 'thestring' must be a pointer
  261. ;;; to a Pascal-type string (at most 255 characters, first byte is string's length).
  262. ;;;
  263. (defun write-pstring (thestream thestring)
  264.   (let ((str-len (%get-byte thestring)))
  265.     (do ((offset 1 (+ 1 offset))) ((> offset str-len))
  266.       (write-char (code-char (%get-byte thestring offset)) thestream))))
  267.  
  268.  
  269. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  270. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  271. ;;;
  272. ;;; Used for logging.
  273. ;;;
  274. ;;; Writes the given character string to the given stream; 'thestring' must be a pointer
  275. ;;; to a C-type string (zero-terminated, no length byte).
  276. ;;;
  277. (defun write-cstring (thestream thestring)
  278.   (do ((offset 0 (+ 1 offset))) ((= 0 (%get-byte thestring offset)))
  279.     (write-char (code-char (%get-byte thestring offset)) thestream)))
  280.  
  281.  
  282. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  283. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  284. ;;;
  285. ;;; Used by the 'equal-pstr-cstr' function.
  286. ;;;
  287. ;;; CHAR-BYTES= returns true if the ASCII characters represented by the two given integers
  288. ;;; are equal and CHAR-BYTES/= returns false if they're equal (both are case insensitive)
  289. ;;;
  290. (defmacro char-bytes= (b1 b2)
  291.   `(char-equal (int-char (coerce ,b1 'integer)) (int-char (coerce ,b2 'integer))))
  292. (defmacro char-bytes/= (b1 b2)
  293.   `(char-not-equal (int-char (coerce ,b1 'integer)) (int-char (coerce ,b2 'integer))))
  294.  
  295.  
  296. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  297. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  298. ;;;
  299. ;;; Used by the 'StringMatch' callback function.
  300. ;;;
  301. ;;; Returns true if the two strings match (case insensitive).  'pstr' must be a pointer to a
  302. ;;; Pascal-type string and 'cstr' must be a pointer to a C-type string.
  303. ;;;
  304. (defun equal-pstr-cstr (pstr cstr)
  305.   (let ((pstr-len (%get-byte pstr)))
  306.     (incf pstr)
  307.     (do ((offset 0 (+ 1 offset)))
  308.         ((or (= offset pstr-len)
  309.              (= 0 (%get-byte cstr))
  310.              (char-bytes/= (%get-byte pstr) (%get-byte cstr)))
  311.          (if (= offset pstr-len)
  312.            t
  313.            (char-bytes= (%get-byte pstr) (%get-byte cstr))))
  314.       (incf pstr)
  315.       (incf cstr))))
  316.  
  317.  
  318. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  319. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  320. ;;;
  321. ;;; The 'StringMatch' callback function:
  322. ;;;
  323. ;;; In the XcmdBlock, inArg1 points to a Pascal-type string, the pattern, and inArg2 points
  324. ;;; to a C-type string, the target.
  325. ;;;
  326. ;;; Performs a case-insensitive search to locate the pattern within the target.  If the pattern
  327. ;;; string is found in the target, a pointer to the first character of the match is returned
  328. ;;; in outArg1, otherwise the null-pointer is returned in outArg1.
  329. ;;;
  330. (defun x-StringMatch ()
  331.   (let ((pattern (%ptr-to-int (rref *params* :XCmdBlock.inArg1)))  ; str255 to locate
  332.         (target (%ptr-to-int (rref *params* :XCmdBlock.inArg2))))  ; c-string in which to look
  333.     (rset *params* :XCmdBlock.outArg1 (%int-to-ptr #x00000000))    ; Default to NULL.
  334.     (when (and (/= 0 pattern) (/= 0 target))
  335.       (do () ((or (= 0 (%get-byte target)) (equal-pstr-cstr pattern target)))
  336.         (incf target))
  337.       (if (/= 0 (%get-byte target))
  338.         (rset *params* :XCmdBlock.outArg1 (%int-to-ptr target))))
  339.  
  340.     (when *logstream*
  341.       (format *logstream* "  Substring '")
  342.       (write-pstring *logstream* pattern)
  343.       (if (= 0 (%ptr-to-int (rref *params* :XCmdBlock.outArg1)))
  344.         (format *logstream* "' not in '")
  345.         (format *logstream* "' in '"))
  346.       (write-cstring *logstream* target)
  347.       (format *logstream* "'."))
  348.  
  349.     $xresSucc))
  350.  
  351.  
  352. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  353. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  354. ;;;
  355. ;;; The 'ZeroToPas' callback function:
  356. ;;;
  357. ;;; In the XcmdBlock, inArg1 points to a C-type string, the source, and inArg2 points
  358. ;;; to a Pascal-type string, the destination.
  359. ;;;
  360. ;;; Copies the C-string into the Pascal-string's buffer in the Pascal-string format.
  361. ;;;
  362. (defun x-ZeroToPas ()
  363.   (let ((cstr (%ptr-to-int (rref *params* :XCmdBlock.inArg1)))   ;; c-string
  364.         (pstr (%ptr-to-int (rref *params* :XCmdBlock.inArg2)))   ;; str255
  365.         (str-len 0))
  366.     (do () ((= 0 (%get-byte cstr)))
  367.       (incf str-len)
  368.       (%put-byte pstr (%get-byte cstr) str-len)
  369.       (incf cstr))
  370.     (%put-byte pstr str-len)
  371.  
  372.     (when *logstream*
  373.       (format *logstream* "  STRING = '")
  374.       (write-pstring *logstream* pstr)
  375.       (format *logstream* "'"))
  376.  
  377.     $xresSucc))
  378.  
  379.  
  380. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  381. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  382. ;;;
  383. ;;; The 'PasToZero' callback function:
  384. ;;;
  385. ;;; In the XcmdBlock, inArg1 points to a Pascal-type string.
  386. ;;;
  387. ;;; Allocates a handle to enough memory to hold the given string then copies the string there,
  388. ;;; terminated by a zero byte.  The C-string handle is returned in outArg1.
  389. ;;; NOTE: The XCMD is not expected to dispose of the C-string created by this callback, so
  390. ;;; the handle is remembered in the global list *handles* and is disposed of by the 'do-xcmd'
  391. ;;; function when the XCMD finishes executing.
  392. ;;;
  393. (defun x-PasToZero ()
  394.   (let* ((pstr (%ptr-to-int (rref *params* :XCmdBlock.inArg1)))   ;; str255
  395.          (len (%get-byte pstr))
  396.          (h (_NewHandle :D0 (%int-to-ptr (+ 1 len)) :A0)))
  397.     (setq *handles* (cons h *handles*))
  398.     (rset *params* :XCmdBlock.outArg1 h)
  399.     (incf pstr)
  400.     (with-dereferenced-handles ((p h))
  401.       (%put-byte p 0 len)
  402.       (do ((offset 0 (+ 1 offset))) ((= offset len))
  403.         (%put-byte p (%get-byte pstr offset) offset))
  404.  
  405.       (when *logstream*
  406.         (format *logstream* "  STRING = '")
  407.         (write-cstring *logstream* (%ptr-to-int p))
  408.         (format *logstream* "'")))
  409.  
  410.     $xresSucc))
  411.  
  412.  
  413. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  414. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  415. ;;;
  416. ;;; The 'ScanToZero' callback function:
  417. ;;;
  418. ;;; In the XcmdBlock, inArg1 is a handle to a C-type string.
  419. ;;;
  420. ;;; Updates the handle's master pointer to point to the next zero byte in the string.
  421. ;;;
  422. (defun x-scanToZero ()
  423.   (let ((handle (rref *params* :XCmdBlock.inArg1)) ; handle to c-string
  424.         (offset 0))
  425.     (with-dereferenced-handles ((pointer handle))
  426.       (loop
  427.         (when (eq (%get-byte pointer offset) 0)
  428.           (%put-ptr handle (%int-to-ptr (+ (%ptr-to-int pointer) offset)))
  429.           (return nil))
  430.         (incf offset))
  431.       
  432.       (when *logstream*
  433.         (format *logstream* "  STRING = '")
  434.         (write-cstring *logstream* (%ptr-to-int pointer))
  435.         (format *logstream* "'")))
  436.     
  437.     $xresSucc))
  438.  
  439.  
  440. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  441. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  442. ;;;
  443. ;;; The 'StringToNum' callback function:
  444. ;;;
  445. ;;; In the XcmdBlock, inArg1 points to a Pascal-type string.
  446. ;;;
  447. ;;; Returns a signed long-integer in outArg1 equal to the number represented by the string.
  448. ;;;
  449. (defun x-StringToNum ()
  450.   (let* ((str (rref *params* :XCmdBlock.inArg1))   ;; str255
  451.          (num (parse-integer (%get-string str))))
  452.  
  453.     (if *logstream*
  454.       (format *logstream* "  NUMBER = ~D" num))
  455.  
  456.     (rset *params* :XCmdBlock.outArg1 num)))
  457.  
  458.  
  459. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  460. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  461. ;;;
  462. ;;; Used by the 'do-xcmd' function.
  463. ;;;
  464. ;;; Given a lisp string, allocates a handle to enough memory to hold the string
  465. ;;; then copies the string there, terminated by a zero byte
  466. ;;;
  467. (defun make-cstr-handle (lisp-string)
  468.   (let* ((len (length lisp-string))
  469.          (cstr-handle (_NewHandle :D0 (%int-to-ptr (+ 1 len)) :A0)))
  470.     (with-dereferenced-handles ((cstr-ptr cstr-handle))
  471.       (%put-byte cstr-ptr 0 len)
  472.       (do ((offset 0 (+ 1 offset))) ((= offset len))
  473.         (%put-byte cstr-ptr (aref lisp-string offset) offset)))
  474.     cstr-handle))
  475.  
  476.  
  477. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  478. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  479. ;;;                                                                                         ;;;
  480. ;;;                       E  N  T  R  Y     F  U  N  C  T  I  O  N  S                       ;;;
  481. ;;;                                                                                         ;;;
  482. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  483. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  484. ;;;
  485. ;;; Get-XCMD-Handle:
  486. ;;;
  487. ;;; Returns a handle to the named 'XCMD' or 'XFCN' resource.  If that resource
  488. ;;; is not in the currently open resource file, the function tries to find it
  489. ;;; in the file given by 'resource-file-path'.  If 'resource-file-path' is nil,
  490. ;;; the function tries to find it in a file named <xcmd-name>, <xcmd-name> + '.xcmd',
  491. ;;; or <xcmd-name> + '.xfcn' in the 'ccl;' folder or the 'xcmd;' folder.
  492. ;;;
  493. ;;; By default, the function first tries to get an XCMD with the given name
  494. ;;; and, upon failure, tries to get an XFCN with that name.  To force it to
  495. ;;; try in the reverse order, supply T for the optional 'XFCN-P' argument.
  496. ;;;
  497. (defun get-xcmd-handle (xcmd-name &optional resource-file-path xfcn-p)
  498.   (with-pstrs ((xcmd-name-pstr xcmd-name))
  499.     (let* ((old-currentResFile (_CurResFile :errchk :word))
  500.            (xcmd-handle (if xfcn-p
  501.                           (_GetNamedResource :ostype "XFCN" :ptr xcmd-name-pstr :ptr)
  502.                           (_GetNamedResource :ostype "XCMD" :ptr xcmd-name-pstr :ptr)))
  503.            (err (_ResError :word)))
  504.       (when (/= err $noErr)
  505.         (setq xcmd-handle (if xfcn-p
  506.                             (_GetNamedResource :ostype "XCMD" :ptr xcmd-name-pstr :ptr)
  507.                             (_GetNamedResource :ostype "XFCN" :ptr xcmd-name-pstr :ptr)))
  508.         (setq err (_ResError :word)))
  509.       (when (/= err $noErr)
  510.         (when (null resource-file-path)
  511.           (setq resource-file-path
  512.                 (or (probe-file (format nil "ccl;~A" xcmd-name))
  513.                     (probe-file (format nil "ccl;~A.xcmd" xcmd-name))
  514.                     (probe-file (format nil "ccl;~A.xfcn" xcmd-name))
  515.                     (probe-file (format nil "xcmd;~A" xcmd-name))
  516.                     (probe-file (format nil "xcmd;~A.xcmd" xcmd-name))
  517.                     (probe-file (format nil "xcmd;~A.xfcn" xcmd-name)))))
  518.         (cond
  519.          ((null resource-file-path)
  520.           (error "Can't find XCMD/XFCN resource '~A'" xcmd-name))
  521.          ((not (probe-file resource-file-path))
  522.           (error "Can't find resource file '~A'"
  523.                  (expand-logical-namestring resource-file-path)))
  524.          ((= -1 (with-pstrs ((path-str (expand-logical-namestring resource-file-path)))
  525.                   (_OpenResFile :errchk :ptr path-str :word)))
  526.           (_UseResFile :errchk :word old-currentResFile)
  527.           (error "Bad resource file '~A'" (expand-logical-namestring resource-file-path)))
  528.          (t
  529.           (setq xcmd-handle (_GetNamedResource :ostype "XCMD" :ptr xcmd-name-pstr :ptr))
  530.           (setq err (_ResError :word))
  531.           (when (/= err $noErr)
  532.             (setq xcmd-handle (_GetNamedResource :ostype "XFCN" :ptr xcmd-name-pstr :ptr))
  533.             (setq err (_ResError :word)))
  534.           (when (/= err $noErr)
  535.             (error "Can't find XCMD/XFCN resource '~A' in file '~A'" xcmd-name
  536.                    (expand-logical-namestring resource-file-path))))))
  537.       (when (= 0 (%ptr-to-int xcmd-handle))
  538.         (error "Bad XCMD/XFCN resource '~A'" xcmd-name))
  539.       
  540.       (_UseResFile :errchk :word old-currentResFile)
  541.       (_HNoPurge :A0 xcmd-handle)
  542.       xcmd-handle)))
  543.  
  544.  
  545. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  546. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  547. ;;;
  548. ;;; Do-XCMD:
  549. ;;;
  550. ;;; Given the string name or the handle of an XCMD or XFCN resource and up
  551. ;;; to 16 string parameters, this invokes the XCMD/XFCN, passing it the given
  552. ;;; parameters.  It returns the string result of the call (for an XCMD, the
  553. ;;; error string; for an XFCN, the function value).
  554. ;;;
  555. (defun do-xcmd (xcmd-handle-or-name &rest paramList)
  556.   (unless (or (handlep xcmd-handle-or-name)
  557.               (and (stringp xcmd-handle-or-name)
  558.                    (setq xcmd-handle-or-name (get-xcmd-handle xcmd-handle-or-name))))
  559.     (error "Invalid XCMD/XFCN"))
  560.  
  561.   (if *logstream*
  562.     (format *logstream* "~%---> Now calling XCMD/XFCN at ~D...~%~%" xcmd-handle-or-name))
  563.   
  564.   (let ((old-resource-state (_HGetState :A0 (%int-to-ptr xcmd-handle-or-name) :D0)))
  565.     (_MoveHHi :A0 (%int-to-ptr xcmd-handle-or-name))
  566.     (_HLock :A0 (%int-to-ptr xcmd-handle-or-name))
  567.     
  568.     (unwind-protect
  569.       (progn
  570.         ;; --- SET UP XCMD-BLOCK ---
  571.         (rset *params* :XCmdBlock.paramCount (list-length paramList))
  572.         (do ((plist paramList (cdr plist))
  573.              (param (+ 2 (%ptr-to-int *params*)) (+ param 4))
  574.              (numparams 1 (1+ numparams)))
  575.             ((> numparams 16))
  576.           (if (null plist)
  577.             (%put-ptr param (%int-to-ptr 0))
  578.             (progn
  579.               (unless (stringp (car plist))
  580.                 (error "~:r XCMD parameter (~:r function argument) is not a string"
  581.                        numparams (1+ numparams)))
  582.               (%put-ptr param (make-cstr-handle (car plist)))
  583.               (setq *handles* (cons (%get-ptr param) *handles*)))))
  584.         (rset *params* :XCmdBlock.returnValue (%int-to-ptr 0))
  585.         (rset *params* :XCmdBlock.entryPoint (%int-to-ptr callback-handler))
  586.         
  587.         ;; --- JUMP TO THE XCMD/XFCN RESOURCE ---
  588.         (with-dereferenced-handles ((xcmd-ptr xcmd-handle-or-name))
  589.           (ccl::ff-call xcmd-ptr :ptr *params* :novalue)))
  590.       
  591.       ;; --- RESTORE THE RESOURCE'S ORIGINAL STATE ---
  592.       (_HSetState :A0 (%int-to-ptr xcmd-handle-or-name) :D0 old-resource-state)
  593.       
  594.       ;; --- CONVERT THE XCMD/XFCN's RESULT C-STRING TO A LISP STRING ---
  595.       (let ((cstr-handle (%ptr-to-int (rref *params* :XCmdBlock.returnValue)))
  596.             (lisp-result-string ""))
  597.         (when (/= 0 cstr-handle)
  598.           (let ((pstr (_NewPtr :D0 (%int-to-ptr 256) :A0))   ;; str255
  599.                 (str-len 0))
  600.             (if (/= 0 (%ptr-to-int cstr-handle))
  601.               (with-dereferenced-handles ((cstr cstr-handle))
  602.                 (setq cstr (%ptr-to-int cstr))
  603.                 (do () ((= 0 (%get-byte cstr)))
  604.                   (incf str-len)
  605.                   (%put-byte pstr (%get-byte cstr) str-len)
  606.                   (incf cstr))))
  607.             (%put-byte pstr str-len)
  608.             (setq lisp-result-string (%get-string pstr))
  609.             (_DisposPtr :A0 (%int-to-ptr pstr))))
  610.         
  611.         ;; --- DISPOSE OF MEMORY ALLOCATED BY 'PasToZero' CALLBACKS (AND PARAMETER STRINGS) ---
  612.         (do () ((null *handles*))
  613.           (_DisposHandle :A0 (car *handles*))
  614.           (setq *handles* (cdr *handles*)))
  615.         
  616.         (if *logstream*
  617.           (format *logstream* "~%The XCMD has finished executing.~%~A~%" lisp-result-string))
  618.         
  619.         ;; --- RETURN "THE RESULT" OF THE XCMD CALL (OR THE FUNCTION VALUE OF THE XFCN CALL) ---
  620.         lisp-result-string))))
  621.  
  622.  
  623. (provide 'xcmd-access)
  624. (pushnew :xcmd-access *features*)
  625.  
  626.  
  627.  
  628. #|
  629.  
  630. EXAMPLES:
  631. --------
  632.  
  633. (setq *logstream* *standard-output*)
  634.  
  635.  
  636.   To use MacroMind's 'PlayMovie' XCMD --
  637.  
  638.     1. With ResEdit, create a resource file containing the XCMD and place
  639.        it into the folder your 'Macintosh Allegro Lisp' application is in.
  640.  
  641.     2. Copy the 'MacroMind Player' application, as well as the movies you
  642.        want to play and the sounds they use, into the folder your 'Lisp'
  643.        application is in.
  644.  
  645.     3. Go!
  646.  
  647.  
  648. ;;; Without preloading the XCMD or the movie:
  649. (do-xcmd "PlayMovie" "Explosion" "movieNoClear" "movieNoUpdate")
  650.  
  651.  
  652. ;;; Preloading the XCMD but not the movie:
  653. (setq playMovie (get-xcmd-handle "PlayMovie"))
  654. (do-xcmd playMovie "Explosion" "movieNoClear" "movieNoUpdate")
  655.  
  656.  
  657. ;;; Preloading the movie but not the XCMD:
  658. (do-xcmd "PlayMovie" "Explosion" "moviePreload")
  659. (do-xcmd "PlayMovie" "movieNoClear" "movieNoUpdate")
  660.  
  661.  
  662. ;;; Preloading both the XCMD and the movie:
  663. (setq playMovie (get-xcmd-handle "PlayMovie"))
  664. (do-xcmd playMovie "Explosion" "moviePreload")
  665. (do-xcmd playMovie "movieNoClear" "movieNoUpdate")
  666.  
  667.  
  668. |#
  669.